Developer CD Series 1994 August: Tool Chest/Dev.CD Aug 94.toast/Tool Chest/Development Platforms/Macintosh Common Lisp Related/User Contributions/print-u.lisp

Text File | 1994-06-20 | 81.5 KB | 2,021 lines | [TEXT/CCL2]

(in-package :ccl)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; print-u.lisp
;;
;; Copyright  1992,1993, 1994 University of Toronto, Department of Computer Science
;; All Rights Reserved
;;
;; author: Mark A. Tapia [e-mail] or [e-mail]
;;
;; print-u is a package for printing windows and documents.
;; The following methods and functions are exported:
;;        get-printer-error     for returning the error condition or nil (no error)
;;        page-size             point indicating the page size used for printing
;;        picture-hardcopy      for quickdraw pictures
;;        print-contents        for drawing the nested views of a window
;;        view-print-contents   for printing a series of views
;;        scale-line-width      sets the scaling factor for line width for PostScript devices
;;        normal-line-width     sets PostScript line width to (1 1)
;;        set-print-reduction   sets the enlargement/reduction percentage between min and max
;;        get-print-reduction   returns the integer corresponding to the percentage
;;                              enlargement/reduction
;;        set-print-orientation sets the print orientation to :portrait or landscape
;;        get-print-orientation returns the print orientation of either :portrait or landscape
;;        get-print-page        returns the page rectangles for the prec fields
;;
;; Internal (unexported) routines of interest
;;        document-hardcopy    for printing a general document
;;        window-hardcopy      for printing the contents of a window using
;;                             print-contents

;;                             Routines that handle public and private print records
;;        check-print-prec     retrieves and validates the print record (get-print-prec object)
;;        default-prec         creates a default private print record
;;        get-prec             retrieves (and possibly creates) a print record for an object
;;        get-print-prec       calls get-prec on the outermost containing view
;;        prec-get             retrieves a print record for an object
;;        prec-put             associates a print-record with an object
;;        remove-prec          removes a print-record associated with an object
;;        remove-hc-prec       removes the public print-record
;;        replace-prec         replaces the print record associated with the object
;;                             only if it is different
;;        update-file-prec     saves a copy of a private print record in a resource
;;        view-file-name       the pathname of the file associated with an object
;;
;; Acknowledgements:
;;     This code is based on print-utils.lisp written by DEH 6/20/91 and
;;     based on hardcopy.lisp with copyright 1988-89 Apple Computer, Inc.
;;     The print-utils code has been modified to work in MCL2.0 and
;;     to print the contents of other views and to support generalized printing.
;;
;;     This code also uses the with-view-font and with-pen-state macros
;;     from oodles-of-utils:quickdraw-u.lisp by Michael S. Engber.
;;     Copyright  1991 Northwestern University Institute for the Learning Sciences
;;     All Rights Reserved.
;;
;;     Support for private print records was based on suggestions by Gregory
;;     Wilcox. The ideas were refined by Bill St. Clair.
;;
;;     Support for the setLineWidth PostScript command based on suggestions
;;     by Kemi Jona.
;;
;;     Changes to support Apple ImageWriters were suggested by
;;     Walker Sigismund, with help from Bill St. Clair.
;;
;;     Changes to support the LaserWriter 8 are the result of reports by users.
;;     Bill St. Clair found the bug and made the changes to save and restore
;;     the print record flags. The changes are marked with ***bill.
;;
;; Update history:
;;  1992-06-07  Added page-size method for retrieving the page size
;;  1992-10-27  Addeed support for private print records stored with the
;;              file in the resource fork (:type :prec :resource-id 128).
;;  1993-02-08  Added support for setLineWidth for PostScript lines.
;;              Replaced (require :QuickDraw) with macro with-rectangle-arg
;;              and function setup-rect, if not present.
;;  1993-08-14  Added macro with-saved-gworld and modified with-open-document
;;              to suppport the ImageWriter.
;;  1993-12-21  Added functions to specify page setup parameters without calling
;;              pageSetup. The functions control enlargement/reduction and
;;              the orientation (portrait/landscape).
;;  1994-06-17  Modifications to support LaserWriter 8.1.1. Problems occured
;;              since the new laserWriter interacts in subtle ways. In particular,
;;              the new driver changes the (href ,pRec :tprint.prflag1.flags)
;;              during the calls to the #_prJobMerge and #_prJobDialog trap calls.
;;              The new driver displays its own print progress dialog box, obviating
;;              the need. However, it does need to say press command-period to cancel.
;;              The version of print-u does not display a print progress dialog box.
;;              It will, however accept the cancel command (command-period) to
;;              cancel printing after completing the print job dialog.
;;              The printing stops after completing a full page for non-fred windows.
;;
;; NOTE: Every window has a private print record which controls the
;;       way the window will be printed and the attributes in the
;;       print-style-dialog box. The private print record is stored in the
;;       resource fork of the file when it is saved (:type :prec :resource-d 128)
;;       and when the Page Setup method is selected.
;;       The private print record is restored when the file is edited again.
;;
;;       Every specific view uses the private print record of the outermost
;;       view containing the specific view.
;;
;;       A private print record of a window is saved when the window
;;       is saved (using Save, Save As, or Save Copy As and when the
;;       window is closed and needs to be saved. Methods are defined
;;       for fred windows.
;;
;;       For all other windows, you must provide a method for saving
;;       the file (ccl::window-save using ccl::window-file-save which
;;       must return the pathname) and a method for (view-file-name window)
;;
;;       When a titled fred-window is saved (using the file menu
;;       items "save", "Save As ..." "Save Copy As..."), the page
;;       setup attributes are saved in a print record in the file.
;;       The record is placed in the :prec resource with id 128.
;;       When the file is reopened in a fred-window, the page setup
;;       attributes are restored.
;;
;;
;;       Every other object uses a shared, public print record *print-hc-prec*.
;;       This print record is initialized at the beginning of a session.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Warnings:
;;     1. If you are running MCL2.0b1p3 or earlier, you must remove
;;        the semi-colons from before the (pushnew ...) form below.

;;(pushnew :not-mcl-final *features*)

;;
;;     2. This code will only work if the records definitions in the
;;        library;interfaces:printTraps.lisp are correct.
;;        See the note below.
;;
;;     3. The code has been tested with LaserWriters but has not
;;        been tested with ImageWriters, StyleWriters etc. The routines
;;        use standard quickdraw calls.
;;
;;     4. This code changes the File menu-items for Page Setup and Print.
;;        The Page Setup menu item is changed to a window-menu-item and
;;        the associated menu-item action is #'ccl::page-setup.
;;        Changing the page setup for a window does not affect
;;        other windows.
;;
;;     5. Printing can only be cancelled by pressing Command-period.
;;        Printing cannot be stopped while the current page is being
;;        printed. but will be stopped before printing the next page.
;;
;;     6. Due to a bug in background printing, we cannot display the
;;        current page being printed under certain conditions.
;;        When the print monitor is displaying the status of printing
;;        (with background printing off), (event-dispatch) does not return.
;;        As a result, the print progress dialog box does not indicate the
;;        page number of the page being printed.
;;        This problem disappears with the LaswerWriter8 driver.
;;
;;     7. The internal code for printing a document runs without interrupts
;;        with the result that no other work can proceed until either
;;        the hardcopy routine returns (or aborts) or is cancelled by
;;        pressing command-period.
;;
;;     8. If you are using oodles-of-utils (the oou: package), and have
;;        loaded quickdraw-u, print-u redefines the with-pen-state and
;;        with-font-spec macros.
;;
;;     10.If you are not running the laswerwriter software 8.0 or later,
;;        comment the code below.
(eval-when (eval load compile) (pushnew :laserwriter8 *features*))
;;
;;
;;  Eight examples of using the package are included at the end of this file:
;;    five printing examples, for printing various objects:
;;    - a small window
;;    - a picture
;;    - a large window
;;    - a general document
;;    - a window with a view-draw-contents method that calls print-contents
;;    and two examples of using private print records
;;    - creating a file, changing its print record, saving it and restoring it.
;;    - developing a class of views that store a print record in a slot
;;    and one example that prints a picture with fractional line widths
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
;;---------------------------Note-------------------------------------

****Warning****
Before loading this file, evaluate
    (record-length :TPrint)
This should return 120.

If the record-length is not 120, the tprstl and tprxinfo records
in the file printTraps.lisp in interfaces folder in the library
folder must be replaced by the following:

(defrecord tprstl
  (wdev :signed-integer)
  (ipagev :signed-integer)
  (ipageh :signed-integer)
  (bport :signed-byte)
  (feed :unsigned-byte))

(defrecord tprxinfo
  (irowbytes :signed-integer)
  (ibandv :signed-integer)
  (ibandh :signed-integer)
  (idevbytes :signed-integer)
  (ibands :signed-integer)
  (bpatscale :signed-byte)
  (bulthick :signed-byte)
  (buloffset :signed-byte)
  (bulshadow :signed-byte)
  (scan :unsigned-byte)
  (bxinfox :signed-byte))

Perform the following steps to update the record definitions:
1. Replace the record definitions in the source file
   library;interfaces:printTraps.lisp with the definitions above.
2. Evaluate the following expression to rebuild the index files
   (ccl::reindex-interfaces)
   You will now be able to access the new record definitions.
3. Quit from MCL. To free up the cons space.
4. Startup MCL again.

----------------------Exported routines------------------------

The following exported routines allow the user to change the
print style for windows. Changing a print style only affects the
current session. The print styles are reset upon re-entering MCL
and are not stored with the document. Changing the style for
a fred window only changes the style of all fred windows during
the session. Similarly changing the style of a non-fred window
only changes the styles for all fred windows.

page-setup                              ; method
Changes the print style for a window.

(page-setup fred-window)
Same as selecting the file Page Setup menu item from the
standard *file-menu*.
Displays the page setup dialog box and allows the user to
change the style attributes for printing the window
but does not affect the style for printing other windows
or documents.

(page-setup t)
Displays the page setup dialog box and allows the user to
change the style attributes for all items that do not have
private print records.

page-size                              ; method
Returns a point indicating the page size used for printing
fred or non-fred windows. The page-size for a fred window
may be different from that of a non-fred window.

(page-size fred-window)
(page-size t)

The following exported routines direct output to a printer or
to a PostScript file.

picture-hardcopy                        ; function
picture-hardcopy picture &optional show-dialog?
  Directs the quickdraw picture to the printer
    picture       a picture
    show-dialog?  ignored

   If no printer errors occurred and the user did not cancel
      returns nil
   otherwise
      returns the non-zero print error code which caused the termination

print-contents                          ; method
print-contents view &optional (offset #@(0 0))
Executes the quickdraw commands for drawing the contents of a view.

When offset is #@(0 0), uses local coordinates for drawing,
otherwise adjusts coordinates by subtracting offset from coordinates.

Print-contents supports the following types of views:
    window                    - draws a box around the content area
                                of the window and prints the contents
                                of the subviews.

    static-text-dialog-item   - draws a box around the item
                                and prints the text with the view font

    editable-text-dialog-item - draws a box around the item
                                and prints the text with the view font

    button-dialog-item        - draws the button and the text within

    view                      - prints the contents of the subviews

    sv                        - does nothing

get-printer-error                       ; function
(get-printer-error)
either returns nil or a printer-condition
If nil, indicates no errors occurred during the last print request.
Otherwise, returns the printer-condition with slots:
phase - either $err-printer??? or nil
code  - either the code returned from the printer operation or nil
cond  - either nil or an error condition when not a printer error


                                        ; PostScript
-- PostScript routines --
The scale-line-width and normal-line-width routines affect PostScript
devices only. Use these commands in document-hardcopy or to create
a picture printed by picture-hardcopy, when using a PostScript device.

For details on set-line-width and picture comments, see Mac Tech Notes #175
(SetLineWidth Revealed) and #91 (Optimizing for the LaserWriter - Picture
Comments).

(scale-line-width scale)                ; function
Sets the scale factor for the Postscript pen width, has no effect
on QuickDraw devices.

Scale is the rational used for scaling the Quickdraw pen width
For the thinest lines possible on a LaserWriter at Reduce/Enlarge=100%
  (1) set the quickdraw pen width to #@(1 1)
  (2) call (scale-line-width 1/4)

(normal-line-width)                     ; function
Sets the scale factor to 1 for the Postscript pen width, has no effect
on QuickDraw devices.

(set-print-reduction t percentage)      ; method
Sets the print reduction/enlargement of the printer record associated
with the object to the integer percentage. The percentage must be in
the range specified by the izoomMin and :izoomMax fields of the tprint record.

(get-print-reduction t)                 ; method
Returns the integer corresponding to the reduction/enlargement
of the printer record associated with the object.

(set-print-orientation t orientation)   ; method
Sets the orientation of the printer record associated with the object
to orientation (either :portrait or :landscape)

(get-print-orientation t)               ; method
Gets the orientation of the printer record associated with the object
to orientation -- either :portrait or :landscape.

(get-print-page t)                      ; method
Returns as values the points corresponding the rectangles for
the various print page boundaries.


----------------------Unexported routines------------------------

Window-hardcopy prints the contents of a window.
Specialize if you want to acheive different effects for
other kinds of windows.

Use view-print-contents to initiate the printing of a view
and all of its subviews.

Use the print-contents methods as the basis for developing
methods for other types of views.

Document-hardcopy is a general routine that forms the basis
for other print routines. Call this routine if you want
to develop your own custom printing functions fo documents
and windows.

window-hardcopy                         ; method
window-hardcopy (window window) &optional (show-dialog? t)
   Prints the window, The show-dialog? parameter is present
   for compatibility with the standard method for fred-windows
   and is used to display the print job dialog.

   The basic routine calls print-contents on the window, which
   repeatedly calls print-contents on the views and subviews.

   If no printer errors occurred and the user did not cancel
      returns t
   otherwise
      returns nil indicating an error occurred in printing

    Parameters
      window           the window to be printed
       show-dialog?    display the print job dialog (default t)


document-hardcopy                       ; not exported
document-hardcopy  print-fn compute-doc-size &key view (show-dialog? t)
   Prints a document. The show-dialog? parameter is present
   for compatibility with the standard method for printing
   fred-windows and is used to display the print job dialog.

   This routine is the basis for picture-hardcopy and window-hardcopy.
   Use document-hardcopy to build other specialized hardcopy routines.

   If no printer errors occurred and the user did not cancel
      returns t
   otherwise
      returns nil indicating an error occurred in printing

   The routine performs the following sequence of operations
   1. Opens the printer
   2. Displays the print job dialog box which indicates the method for cancelling.
   3. Retrieves the print record
   4. Determines the page layout using the rectangle corners
      returned by the document-corners function
   5. Opens the printer document
   6. While there are pages to print and the user has not pressed cancel
         For each page in the document that is to be printed, repeats the
         following steps
            a. opens the page
            b. draws the page using the print-fn
            c. closes the page
   7. Closes the printer document
   8. Closes the printer
   9  If no printer errors occurred and the user did not cancel
         returns t
      otherwise
         returns nil indicating an error occurred in printing
      Use (get-printer-error) to retrive the printer error condition.

    Parameters
    document-corners
                  Function that computes the corners of the document
                  Parameters:
                       view         the view associated with the document
                       page-size    a point representing the size of the
                                    page-rectangle in pixels
                  Returns the corners of the document rectangle
                  Where the default points are #@(0 0) page-size
                       topleft      the top left corner
                       bottomRight  the bottom right corner
                  If document-corners is not a function, uses the routine
                  default-document-corners which returns the points defining
                  the page rectangle.

   print-fn       Function that draws a picture of the document.
                  Parameters:
                       view        suppled by the view keyword. This should be a view
                                   or nil.
                       page-size   the page rectangle size as a point (top left = #@(0 0))
                       page-no     the current page being printed
                       offset      the top left corner of the portion of the document
                  If local, prints the rectangular portion of the document defined
                     by the points offset (add-points offset page-size). The
                     coordinates are unchanged.
                  Otherwise, adjusts the coordinates by subtracting offset
                     from all points to print within the page rectangle #@(0 0)
                     page-size.

                  If print-fn is not a function, uses default-document-hardcopy
                  which does nothing.

   :view          the view, default is nil for no view. Passed as a parameter to
                  document-corners and print-fn.

   :show-dialog?  display the print job dialog (default t)

   :local         default is t. If true, use the document coordinates while printing
                  otherwise use coordinates within the page rectangle,
                  by adjusting all coordinates by offset.

|#

(export '(picture-hardcopy print-contents page-setup get-printer-error page-size
          set-print-reduction get-print-reduction set-print-orientation
          get-print-orientation get-print-page))

(provide 'print-u)



;; prepare to redefine the functions get-prec and remove-prec by a standard generic function
(progn
  (when (and (fboundp 'get-prec)
             (equal (type-of #'get-prec) 'function))
    (fmakunbound 'get-prec))
  (when (and (fboundp 'remove-prec)
             (equal (type-of #'get-prec) 'function))
    (fmakunbound 'remove-prec))
  (setq *save-exit-functions*
        (remove 'remove-prec *save-exit-functions* :key #'function-name)))

(eval-when (eval load compile)
  (require :resources))

#-not-mcl-final
(eval-when (eval compile)
  (require :quickDraw))
#+not-mcl-final
(eval-when (eval compile)
  (ccl::require-interface :printTraps)
                                        ;(require :quickDraw) replaced by two macros below
  (require :loop)                       ; loop is automatically included in MCL 2.0f
  )


;; Routines from quickdraw-u.lisp from Michael S. Engber
;;     Copyright  1991 Northwestern University Institute for the Learning Sciences
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *full-debug* nil)         ; full debugging, prints all trap calls
                                        ; change to t for full debugging information

;; use this definition if you want full debugging
(defmacro call-trap (flag trap &rest args)
  `(progn
     (when *full-debug*
     (format t " (trap ~a " ,flag))
     (prog1
       (require-trap ,trap  . ,args)
       (when *full-debug*
         (format t "--> ~a) " ,flag)))))

;; the following macros are standard in MCL2.0 final
#+not-mcl-final
(eval-when (:compile-toplevel :load-toplevel :execute)

  (unless (fboundp 'href)
    (defmacro href (pointer accessor)
      `(rref ,pointer ,accessor :storage :handle)))

  (unless (fboundp 'pref)
    (defmacro pref (pointer accessor)
      `(rref ,pointer ,accessor :storage :pointer))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (fboundp 'hset)
    (defmacro hset (pointer accessor thing)
      `(rset ,pointer ,accessor ,thing :storage :handle)))

  (unless (fboundp 'pset)
    (defmacro pset (pointer accessor thing)
      `(rset ,pointer ,accessor ,thing :storage :pointer)))

  (unless (fboundp 'with-rectangle-arg)
    ; add quickdraw support routines
    (defmacro with-rectangle-arg ((var left &optional top right bottom) &body body)
      "takes a rectangle, two points, or four coordinates and makes a rectangle.
body is evaluated with VAR bound to that rectangle."
      `(rlet ((,var :rect))
         (setup-rect ,var ,left ,top ,right ,bottom)
         ,@body))

    (defun setup-rect (rect left top right bottom)
      (cond (bottom
             (setf (pref rect rect.topleft) (make-point left top))
             (setf (pref rect rect.bottomright) (make-point right bottom)))
            (right
             (error "Illegal rectangle arguments: ~s ~s ~s ~s"
                    left top right bottom))
            (top
             (setf (pref rect rect.topleft) (make-point left nil))
             (setf (pref rect rect.bottomright) (make-point top nil)))
            (t (%setf-macptr rect left))))
    )

  (unless (fboundp 'with-font-spec)
    (defmacro with-font-spec (font-spec &body body)
      (if (and (listp font-spec) (every #'constantp font-spec))
        (multiple-value-bind (ff ms) (font-codes font-spec)
          `(with-font-codes ,ff ,ms ,@body))
        (let ((ff (gensym))
              (ms (gensym)))
          `(multiple-value-bind (,ff ,ms) (font-codes ,font-spec)
             (with-font-codes ,ff ,ms ,@body))))))

  (unless (fboundp 'with-pen-state)
    (defmacro with-pen-state ((&key pnLoc pnSize pnMode pnPat pnPixPat) &body body)
      (let ((state (gensym)))
        `(rlet ((,state :PenState))
           (call-trap 'getPenState #_GetPenState :ptr ,state)
           (unwind-protect
             (progn
               ,@(when pnLoc    `((call-trap 'moveTo #_MoveTo :long ,pnLoc)))
               ,@(when pnSize   `((call-trap 'penSize #_PenSize :long ,pnSize)))
               ,@(when pnMode   `((call-trap 'penMode #_PenMode :signed-integer ,pnMode)))
               ,@(when pnPat    `((call-trap 'penPat #_PenPat :ptr ,pnPat)))
               ,@(when pnPixPat `((call-trap 'penPixPat #_PenPixPat :ptr ,pnPixPat)))
               ,@body)
             (call-trap 'setPenState #_SetPenState :ptr ,state)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; end of macros from quickdraw-u.lisp

(defun set-page-range (prec pages-to-print)
  (hset prec :tprint.prjob.iFstpage 1)
  (hset prec :tprint.prjob.iLstpage pages-to-print))

(unless (fboundp 'copy-handle)
  (defun copy-handle (handle)
    (rlet ((h :pointer))
      (setf (%get-ptr h) handle)
      (call-trap 'handToHand #_HandToHand h)
      (%get-ptr h)))
  (export 'copy-handle))

(defvar *printing* nil "Printing not in progress")
(defvar *print-record-window* nil "window containg the view being printed")
(defvar *mcl-get-print-record* #'get-print-record)
(defparameter *debug* nil)              ;  for debugging only
(defparameter *full-debug* nil)         ;  for extensive debugging only

(defparameter *print-error* nil "The printing error in the form printer-condition")
(defvar *print-hc-prec*)                ; the default print-record

;; condition for printer errors
(define-condition printer-condition (error)
  (phase code cond)
  (:report (lambda (condition stream)
             (with-slots (phase code cond) condition
               (if cond
                 (format stream "Printer error ~s" cond)
                 (format stream "Printer error ~s in phase ~s" code phase))))))

;; condition for a user-cancel for a print operation
(define-condition user-cancel (printer-condition))



;; functions for converting coordinates from one system to another
(defun convert-offset (window container offset)
  ;; If the container is a view, returns in window coordinates,
  ;; the point offset which is expressed in container coordinates
  ;; Otherwise returns the offset.
  (subtract-points
   (if container
     (convert-coordinates #@(0 0) container window)
     #@(0 0))
   offset))

(defmethod window-view-corners ((self view) &optional (offset #@(0 0)))
  ;; returns the coordinates of the view corners in window coordinates
  ;; offset by offset
  (let ((container (view-container self))
        (window (view-window self)))
    (multiple-value-bind (topLeft bottomRight)
                         (view-corners self)
      (setq offset (convert-offset window container offset))
      (values (add-points topLeft offset) (add-points bottomRight offset)))))

(defmethod window-view-corners ((self dialog-item)  &optional (offset #@(0 0)))
  ;; returns the coordinates of the view corners of a dialog item
  ;; in window coordinates offset by offset
  (let ((container (view-container self))
        (window (view-window self)))
    (multiple-value-bind (topLeft bottomRight)
                         (view-corners self)
      (setq offset (convert-offset window container offset))
      (values (add-points topLeft offset) (add-points bottomRight offset)))))

;;; Modified routines from print-utils.lisp for printing the contents of a views
;;; converted from MCL1.3.2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;hardcopy.lisp
;;
;;
;;copyright 1988-89 Apple Computer, Inc.
;;
;; defines a very basic printing routine for windows
;;
;; Code taken from Apple and Bill Kornfeld and played with a bit to get
;; something working.  Trying to change the wptr and
;; then doing a view-draw-contents fails --- LISP unexpectantly quits.
;; view-draw-contents without changing the window pointer
;; causes a print job to be sent to the printer but nothing comes out.
;; Using a print-contents function that just makes the appropriate
;; calls seems to work ok. The basic print-contents
;; quickdraw functions for text, views and windows are defined here.
;; Some extra print-contents functions for other items is defined in
;; odin-printing.lisp -- DEH 6/20/91

;;;------------------ Printer constants----------------------------------------
(defconstant $err-printer 94)
(defconstant $err-printer-load 95)
(defconstant $err-printer-start 97)

;;;------------------ Picture comment operand ---------------------------------
(defconstant $set-line-width 182 "Picture comment for setting line width")

;;;------------------ Routine for trapping printer errors----------------------
(defun printer-ok (&optional (errnum $err-printer)
                             &aux (print-error (call-trap 'prError #_prError)))
  ;; Checks for a printer error for the last printer command
  ;; If there was an error, sets *printing* to nil
  ;;   and if there has not been a previous printing error
  ;;   sets the *print-error* to `(,errnum ,error)
  (if (zerop print-error)
    t
    (progn
      (unless *print-error*
        (setq *print-error* (make-condition 'printer-condition))
        (setf (slot-value *print-error* 'phase) errnum
              (slot-value *print-error* 'code) print-error
              (slot-value *print-error* 'cond) nil))
      (setq *printing* nil)
      (signal 'user-cancel))))

(defmacro check-printer-ok (form &optional (errnum $err-printer))
  "Checks that the printer is ok after the execution of the form"
  `(progn
     ,form
     (if (printer-ok ,errnum)
       t
       (throw :cancel nil))))

(defun get-printer-error ()
  ;; returns nil or the the last non-zero printer error
  *print-error*)

;;;------------------ The basic print-contents functions-----------------------
(defmethod print-contents ((v window) &optional (offset #@(0 0)))
  "a window draws a box around itself and
   then asks its subviews to print themselves"
  ;;first frame it
  (multiple-value-bind (top-left bottom-right)
                       (window-view-corners v offset)
    (ccl::with-rectangle-arg (r top-Left bottom-right)
      (call-trap 'frameRect #_FrameRect r)))
  (dovector (sv (view-subviews v))
    (print-contents sv offset)))

(defmethod print-contents ((v view) &optional (offset #@(0 0)))
  "a view just asks its subviews to print themselves"
    (dovector (sv (view-subviews v))
      (print-contents sv offset)))

(defmethod print-contents ((sv ccl::basic-editable-text-dialog-item)
                           &optional (offset #@(0 0)))
  "editable text uses textbox -- takes into account font and the justification"
    (multiple-value-bind (top-left bottom-right)
                         (window-view-corners sv offset)
    (with-font-spec (view-font sv)
      (ccl::with-rectangle-arg (r top-Left bottom-right)
        (with-pstrs ((pstring (dialog-item-text sv)))
          (call-trap 'textBox #_TextBox :ptr (%inc-ptr pstring 1)
           :long (length (dialog-item-text sv))
           :ptr r
           :word (slot-value sv 'ccl::text-justification)))))))

(defmethod print-contents ((sv static-text-dialog-item) &optional (offset #@(0 0)))
  "static text uses textbox -- take into account font and the justification"
  (multiple-value-bind (top-left bottom-right)
                       (window-view-corners sv offset)
    (with-font-spec (view-font sv)
      (ccl::with-rectangle-arg (r top-Left bottom-right)
        (with-pstrs ((pstring (dialog-item-text sv)))
          (call-trap 'textBox #_TextBox :ptr (%inc-ptr pstring 1)
           :long (length (dialog-item-text sv))
           :ptr r
           :word (slot-value sv 'ccl::text-justification)))))))

(defmethod print-contents ((sv button-dialog-item)  &optional (offset #@(0 0)))
  (multiple-value-bind (top-left bottom-right)
                       (window-view-corners sv offset)
    (ccl::with-rectangle-arg (r top-left bottom-right)
      (with-font-spec (view-font sv)
        (with-pstrs ((pstring (dialog-item-text sv)))
          (call-trap 'textBox #_TextBox :ptr (%inc-ptr pstring 1)
           :long (length (dialog-item-text sv))
           :ptr r :word 1)))
      ;;; end of with-font-spec
      (with-pen-state (:pnSize #@(1 1)
                               :pnMode #$PATOR
                               :pnPat *black-pattern*)
          (decf (rref r :rect.left)
                (floor (dialog-item-width-correction sv) 2))
          (incf (rref r :rect.right)
                (floor (dialog-item-width-correction sv) 2))
          (call-trap 'frameRoundRect #_FrameRoundRect :ptr r :word 10 :word 6)))))

(defmethod print-contents ((sv simple-view) &optional offset)
  (declare (ignore offset))
  "default if all else fails do nothing"
  t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of modified routines from print-utils.lisp

;;;------------------ handles - checking validity and removing -------------------
(unless (fboundp 'valid-handle)
  (defun valid-handle (handle)
    (when (and handle
               (handlep handle)
               (pointerp handle)
               (macptrp handle)
               (not (equal handle (%null-ptr))))
      handle)))

(defun dispose-handle (handle)
  (when (valid-handle handle)
      (call-trap 'disposeHandle #_disposeHandle handle)))

;;;---------retrieving and changing the value of an internal print-record---------
;; routines do not allocate new print records
(defmethod prec-get ((self view))
  (view-get self :prec))

(defmethod prec-get ((self t))
  (when (boundp '*print-hc-prec*)
    *print-hc-prec*))

(defmethod prec-put ((self view) value)
  (view-put self :prec value))

(defmethod prec-put ((self t) value)
  (setq *print-hc-prec* value))

(defmacro clean-catch-cancel (flag &body body)
  ;; When debugging print the flag
  ;; Execute the body unwind-protected while catching
  ;; cancels, errors, aborts and breaks
  (let ((old-state (gensym)))
   `(let ((,old-state *break-on-errors*))
     (unwind-protect
      (handler-case
       (restart-case
         (catch :cancel
           (when *debug* (format t "~&--->~a~%" ,flag))
           (setq *break-on-errors* nil)
           ,@body)
         (abort () (message-dialog "Printing aborted.")
                (stop-printing))
         (error (condition) (stop-printing condition)))
       (error (condition) (setq *printing* nil) condition))
      (setq *break-on-errors* ,old-state)))))

;;;---------determining the window containing the view (if any)---------
;;  for views returns
;;    either the window containing the view
;;    or the outermost view containing the view
;;  for all other objects returns the object

(defmethod containing-window ((view window))
  view)

(defmethod containing-window ((sub-view view))
  (loop with new-view
        do (setq new-view (view-container sub-view))
        while new-view
        do (setq sub-view new-view)
        finally (return sub-view)))

(defmethod containing-window ((self t))
  self)

;;;---------allocating, modifying and updating the internal print records---------
(defmethod remove-view-from-window :after ((subview view))
  (remove-prec subview))

;; file names associated with views
(defmethod view-file-name ((window fred-window))
  (slot-value window 'ccl::my-file-name))

(defmethod view-file-name ((self t))
  nil)

;;;---------manipulating the internal print records---------
(defmethod remove-prec ((self t))
  ;; clean up the internal tprint handle (if any)
  (dispose-handle (prec-get self))
  (prec-put self nil))

(defmethod replace-prec ((self t) new-value)
  ;; clean up the internal tprint handle (if any)
  (let ((old-value (prec-get self)))
    (unless (eq old-value new-value)
      (remove-prec self)
      (prec-put self new-value))
    new-value))

(defmethod update-file-prec ((self t) prec &optional file-name)
  ;; Saves a copy of the internal print record as a resource.
  ;; Called during a page setup and after saving a file (in this
  ;; case the file-name argument is supplied
  (let ((filename (or file-name (view-file-name self)))
        new-prec
        old-prec)
    (when (valid-handle prec)
      (when (pathnamep filename)
        (with-open-resource-file (refnum filename :if-does-not-exist :create)
          (when *debug* (print-record prec :tprint) (terpri))
          (setq old-prec (get-resource :prec 128 :errorp nil))
          (when (valid-handle old-prec)
            (remove-resource old-prec)
            (dispose-handle old-prec))
          (setq new-prec (copy-handle prec))
          (when *debug* (print-record prec :tprint) (terpri))
          ;; from Inside Macintosh I-123
          (call-trap 'hNOpurge #_HNoPurge new-prec)
          (add-resource new-prec :prec 128)
          (call-trap 'changedResource #_changedResource new-prec)
          (write-resource new-prec)
          (call-trap 'hPurge #_HPurge new-prec)
          new-prec)))))

(defmethod get-prec ((self t))
  (let (printer-record
        (file-name (view-file-name self))
        (view-print-record (prec-get self))
        create)
    ;; retrieves and possibly initializes the private print record
    ;; if the print record exists and is a valid handle
    ;;   returns the handle
    ;; otherwise initializes the private print record
    ;;   tries to read the :prec resource from the view-file-name
    ;;    if successful
    ;;     stores and returns a copy of the resource (handle)
    ;;    otherwise
    ;;     creates a default print record using default-prec
    ;;
    (cond
     ((valid-handle view-print-record) view-print-record)
     ((null (pathnamep file-name)) (create-default-prec self))
     (t (with-open-resource-file (refnum file-name :if-does-not-exist nil)
          (cond
           ((or (null refnum)
                (null (setq printer-record (get-resource :prec 128 :errorp nil))))
            (setq view-print-record (create-default-prec self)
                  create t))
           (t (remove-prec self)
              (setq view-print-record (copy-record printer-record :tprint))
              (replace-prec self view-print-record)))
          (when create
            (update-file-prec self view-print-record))
          view-print-record)))))

(defmethod create-default-prec ((self t))
  (let (view-print-record)
    (remove-prec self)
    (setq view-print-record (default-prec self))
    (replace-prec self view-print-record)
    (update-file-prec self view-print-record)
    view-print-record))

(defmethod get-print-prec ((self t))
  (let ((outer-container (containing-window self)))
    (cond ((null outer-container) (get-prec t))
          ((eq self outer-container) (get-prec self))
          (outer-container (get-prec outer-container))
          (t (get-prec t)))))

;; create a default print-record
(defmethod default-prec ((self t))
  (let (code
        view-print-record)
    (clean-catch-cancel
      :prec
      (remove-prec self)
      (setq view-print-record (call-trap 'newHandle #_NewHandle :errchk (record-length :TPrint)))
      (setq code (call-trap 'memError #_MemError))
      (when (zerop code)
        (replace-prec self view-print-record)
        (if (not (valid-handle view-print-record))
          (setq code "invalid-handle")
          (progn
            (check-printer-ok (call-trap 'printDefault #_PrintDefault :ptr view-print-record))
            (setq code nil)))))
    (if code
      (remove-prec self)
      view-print-record)))


;; routines for allocating/deallocating the tprint handle for printing

(defun stop-printing (&optional condition)
  ;; stop printing
  (setq *printing* nil
        *print-error* (make-condition 'printer-condition))
  (if condition
    (setf (slot-value *print-error* 'phase) nil
          (slot-value *print-error* 'code) nil
          (slot-value *print-error* 'cond) condition)
    (setf (slot-value *print-error* 'phase) $err-printer
          (slot-value *print-error* 'code) #$iPrAbort
          (slot-value *print-error* 'cond) nil))
  (call-trap 'prseterror #_PrSetError #$iPrAbort)
  (error *print-error*))

(defun reset-printing ()
  (setq *printing* nil)
  (call-trap 'prseterror #_prSetError #$NoErr))

;; the method for getting a fred print record
(defmethod get-print-prec ((window fred-window))
  (get-print-record))

(defmethod check-print-prec ((self t))
  ;; gets the tprint handle and validates it
  ;; when successful, returns the tprint handle
  ;; must be called when the printer is open (e.g. within with-printer-open)
  (let ((local-prec (get-print-prec self)))
    (when local-prec
      (clean-catch-cancel
       :check-print
       (check-printer-ok (call-trap 'prValidate #_prValidate :ptr local-prec :boolean))
       local-prec))))

#|                                      ; obsolete routines, replaced by LaserWriter8
;; the print status dialog box (print-dialog) displayed when printing in progress.
(defclass print-dialog (window)
  ()
  (:default-initargs
    :window-type :double-edge-box
    :view-position :centered
    :view-size #@(373 96)
    :close-box-p nil
    :view-font '("Chicago" 12 :srcor :plain)))

#+laserwriter8
(defmethod initialize-instance ((window print-dialog) &rest initargs)
  (apply #'call-next-method window initargs)
  (add-subviews window
                (make-instance 'static-text-dialog-item
                  :view-position #@(10 10)
                  :view-size #@(151 40)
                  :dialog-item-text (format nil
                                            "Printing in progress
To cancel press ~a-." #\CommandMark)
                  :view-nick-name 'title)
                ))

#-laserwriter8
(defmethod initialize-instance ((window print-dialog) &rest initargs)
  (apply #'call-next-method window initargs)
  (add-subviews window
                (make-instance 'static-text-dialog-item
                  :view-position #@(10 10)
                  :view-size #@(151 40)
                  :dialog-item-text (format nil
                                            "Printing in progress
To cancel press ~a-." #\CommandMark)
                  :view-nick-name 'title)

                (make-instance 'static-text-dialog-item
                  :view-position #@(10 72)
                  :view-size #@(120 18)
                  :dialog-item-text "Printing page")

                (make-instance 'static-text-dialog-item
                  :view-position #@(135 72)
                  :view-size #@(36 18)
                  :dialog-item-text ""
                  :view-nick-name 'page)

                ))

(defvar *print-dialog*
  (make-instance 'print-dialog :window-show nil)
  "The printing progress dialog box")

(defmethod get-print-dialog ((self t) &key (display nil) (wait t))
  (declare (ignore self))
  "Displays the printer progress dialog box and waits for 1 second."
  (unless (and *print-dialog* (wptr *print-dialog*) (pointerp (wptr *print-dialog*)))
    (setq *print-dialog* (make-instance 'print-dialog :window-show nil)))
  (when (and *printing* display)
    (with-focused-view *print-dialog*
      (window-show *print-dialog*)))
  (when wait (sleep 1))
  *print-dialog*)

;; default method for removing the print progress dialog box,
;; specialize for other views
(defmethod remove-print-dialog ((self t))
  (when (and *print-dialog* (wptr *print-dialog*))
    (window-close *print-dialog*))
  (setq *print-dialog* nil))

;; default method for indicating printing progress, specialize for other views
;; Note: does not update the page field when background printing is off
(defmethod set-page-number ((self t) page-no &key (display nil))
  "Update the page number field for printing"
  (let* ((print-dialog (get-print-dialog self :display display :wait display))
         (page-field (view-named 'page print-dialog)))
    ; force the window to be updated
    (with-focused-view print-dialog
      (set-dialog-item-text page-field (format nil "~3d" page-no))
      ;(event-dispatch)    ; fails to return when background printing is off
      (sleep 1))))

;; newer version of set-page-number for laserwriter 8
#+laserwriter8
(defmethod set-page-number ((self t) page-no &key (display nil))
  "Update the page number field for printing"
  (declare (ignore page-no display)))

|#

;; methods and functions for working with the printer port as a view
;;  similar to the wmgr-view functions in oodles-of-utils:simple-view-ce.lisp
;; Supplied by Bill St. Clair at Apple.

(defclass printer-view (simple-view)
  ((clip-region :initform nil :accessor printer-view-clip-region)))

(defmethod view-origin ((view printer-view))
  (let ((wptr (wptr view)))
    (if wptr
      (rref wptr :grafport.portrect.topleft)
      #@(0 0))))

(defmethod view-clip-region ((view printer-view))
  (let ((macptr (printer-view-clip-region view)))
    (unless (typep macptr 'macptr)
      (setq macptr
            (setf (printer-view-clip-region view) (%null-ptr))))
    (%setf-macptr macptr (rref (wptr view) :grafport.cliprgn))
    macptr))

(defun make-printer-view (printer-port)
  (let ((topleft (rref printer-port :grafport.portrect.topleft))
        (botright (rref printer-port :grafport.portrect.botright)))
    (make-instance 'printer-view
      :wptr printer-port
      :view-position topleft
      :view-size (subtract-points botright topleft))))

;;  basic macros for using a printer, printing a document and printing a page.
(defmacro with-open-page ((hardcopy-ptr page-size offset &key (local t))
                          &rest body)
  ;; Opens a printer page
  ;; executes the body
  ;; closes the printer upon termination (even when in error)
  ;; returns the result of executing the body
  (let ((r (gensym))
        (vals (gensym)))
    `(let (,vals)
       (clean-catch-cancel
        :open-page
        (rlet ((,r :rect :topLeft #@(0 0) :bottomRight ,page-size))
          (when ,local (call-trap 'offsetRect #_offsetRect :ptr ,r :long ,offset))
          (unwind-protect
            (clean-catch-cancel
             :inner-open-page
             (setq ,vals
                   (multiple-value-list
                    (with-clip-rect ,r
                      (check-printer-ok
                       (call-trap 'prOpenPage #_PrOpenPage
                                     :ptr ,hardcopy-ptr :ptr (if ,local ,r  (%null-ptr))))
                      ,@body))))
            (check-printer-ok (call-trap 'prClosePage #_PrClosePage :ptr ,hardcopy-ptr)))))
       (values-list ,vals))))

(defmacro with-saved-gworld (&rest body)
  ;; Saves the gworld, executes the body of the code and then restores the gworld
  ;; upon termination (normal or abnormal)
  (let ((saved-port (gensym))
        (saved-device (gensym)))
    `(with-macptrs (,saved-port ,saved-device)       ; from Bill StClair at Apple
       (ccl::get-gworld ,saved-port ,saved-device)
       (flet ((restore-gworld ()
                (ccl::set-gworld ,saved-port ,saved-device)))
         (unwind-protect
           (progn ,@body
                  (restore-gworld))
           (restore-gworld)   ; from Bill StClair at Apple
           )))))

(defmacro with-open-doc (hardcopy-ptr prec &rest body)
  ; _PrOpenDoc puts up a dialog window
  ; In order to process events within the body, we must call
  ; event-dispatch, otherwise windows will not be updated
  ; Opens the printer document
  ; Executes the body of code with the local variable
  ;   hardcopy-ptr bound to the printer GrafPort
  ;   prec is a handle to the TPrint record
  ; Closes the printer document upon termination (even when in error)
  ; Returns the result of executing the body
  ;;
  ; without-interrupts appears in the same place as (window-hardcopy fred-window)
  ; before the open-doc (decinest appears at location 332, open-doc at 360-362)
  (let ((vals (gensym))
        (stRec (gensym))
        (printer-view (gensym)))
    `(with-saved-gworld
       (without-interrupts              ; ***bill
        (let ((,hardcopy-ptr
               (call-trap 'prOpenDoc #_PrOpenDoc :ptr ,pRec :ptr (%null-ptr) :ptr (%null-ptr) :ptr))
              ,vals
              ,printer-view)
          (ccl::set-gworld ,hardcopy-ptr)
          ;***bill (without-interrupts
          (clean-catch-cancel
            :open-doc
            (unwind-protect
              (clean-catch-cancel
                :port
                (setq ,printer-view (make-printer-view
                                     ,hardcopy-ptr))
                (check-printer-ok nil $err-printer-start)
                (ccl::set-gworld ,hardcopy-ptr)
                (setq ,vals
                      (multiple-value-list
                       (with-focused-view ,printer-view
                         ,@body))))
              (check-printer-ok (progn
                                  (call-trap 'prCloseDoc #_PrCloseDoc :ptr
                                                ,hardcopy-ptr
                                                )
                                  ;; called after #_PrCloseDoc doc <<<<<<<<
                                  (restore-gworld))))
            (when (= (href ,prec :tprint.prJob.bjDocLoop)
                     #$bSpoolLoop)
              (%stack-block ((,StRec (record-length :tprStatus)))
                (check-printer-ok (progn
                                    (call-trap 'prPicFile #_PrPicFile
                                                  :ptr ,pRec
                                                  :ptr (%null-ptr)
                                                  :ptr (%null-ptr)
                                                  :ptr (%null-ptr)
                                                  :ptr ,StRec)
                                    ;; called after #_PrPicFile doc <<<<<<<<<
                                    (restore-gworld)))
                )))
          (values-list ,vals))))))

(defmacro with-open-printer ((prec &key (view t) (show-dialog? nil)) &rest body)
  ; Opens the printer
  ; Executes the body of code with the local variable
  ;  Closes the printer upon termination (even when in error)
  ;; returns the result of executing the body

  (let ((vals (gensym))
        (saved-flags (gensym)))         ; ***bill
    `(let (,vals ,prec ,saved-flags)
       (unwind-protect
         (clean-catch-cancel
           :open-print
           (setq ,vals
                 (multiple-value-list
                  (unless *printing*
                    (check-printer-ok (call-trap 'prOpen #_PrOpen) $err-printer-load)
                    (setq *printing* t)
                    (when (and (setq ,prec (get-print-prec ,view))
                               (check-print-prec ,view)
                               (or (and (null ,show-dialog?)
                                        (progn
                                          (setq ,saved-flags (href ,pRec :tprint.prflag1.flags))        ; ***bill
                                          (call-trap 'prJobMerge #_prJobMerge :ptr ,pRec :ptr ,pRec)
                                          (when *debug*
                                            (print ,prec)
                                            (print-record ,prec :tprint)
                                            (terpri))
                                          t))
                                   (with-cursor *arrow-cursor*
                                     (when *debug* (print-record ,prec :tPrint) (terpri))
                                     (setq ,saved-flags (href ,pRec :tprint.prflag1.flags))        ; ***mark
                                     (call-trap 'prJobDialog #_PrJobdialog :ptr ,prec :boolean))
                                   (throw :cancel :cancel)))
                      ,@body)))))
         (check-printer-ok (call-trap 'prClose #_PrClose))
         (when *debug* (print-db ,saved-flags)
               (print-record ,prec :tPrint) (terpri))
         (when ,saved-flags             ; ***bill
           (setf (href ,pRec :tprint.prflag1.flags) ,saved-flags))      ; ***bill
         (setq *printing* nil))
       (values-list ,vals))))

;; generalized page-setup routines for objects that are not fred windows
(defmethod page-setup ((self t))
  ;; Atempts to retrieve a valid tprint handle
  ;; If successful displays the page setup dialog using the print record
  ;; Returns t when successful
  (with-cursor *arrow-cursor*
    (with-open-printer (prec :view self)
      (when *debug* (print-record prec :tprint) (terpri))
      (check-printer-ok (call-trap 'prStlDialog #_PrStlDialog :ptr prec :boolean))
      (update-file-prec self prec)
      (when *debug* (print-record prec :tprint) (terpri))
      t)))

;; page setup
;;   for fred windows
(defmethod page-setup ((window fred-window))
  (let ((*print-record-window* window))
    (print-style-dialog)))

;; Rather than use page-setup, define methods for examining and
;; setting printer parameters.

(defmethod set-print-reduction ((self t) reduction)
  (with-open-printer (print-record :view self)
    (if (integerp reduction)
      (when (macptrp print-record)
        (let ((min (rref print-record :tprint.izoommin))
              (max (rref print-record :tprint.izoommax)))
          (if (<= min reduction max)
            (rset print-record :tprint.prxinfo.ibandh reduction)
            (error "~s must be between ~d and ~d" reduction min max))))
      (error "~s must be an integer" reduction))))

(defmethod get-print-reduction ((self t))
  (with-open-printer (print-record :view self)
    (if (macptrp print-record)
      (rref print-record :tprint.prxinfo.ibandh)
      (error "~s is not a macintosh pointer" print-record))))

(defmethod set-print-orientation ((self t) orientation)
  ;; orientation is either :landscape or :portrait
  (with-open-printer (print-record :view self)
    (when (macptrp print-record)
      (let* ((old (rref print-record :tprint.prstl.wdev))
             (old-orientation (ldb (byte 1 1) old))
             (bit (case orientation
                    (:landscape 0)
                    (:portrait 1)))
             ;; experimentally determined that bit one controls orientation
             ;; is this always true?
             new)
        (when bit
          (setq new (dpb bit (byte 1 1) old)))
        (unless (= old-orientation bit)
          (reverse-page-dimensions print-record)
          (rset print-record :tprint.prstl.wdev new))))))

(defmethod get-print-orientation ((self t))
  (with-open-printer (print-record :view self)
    (when (macptrp print-record)
      (case (ldb (byte 1 1)
                 (rref print-record :tprint.prstl.wdev))
        (0 :landscape)
        (1 :portrait)))))

(defun reverse-point (point)
  (make-point (point-v point) (point-h point)))

(defmacro reverse-a-page-field (print-record field)
  `(rset ,print-record ,field
         (reverse-point (href ,print-record ,field))))

(defun reverse-page-dimensions (print-record)
  (reverse-a-page-field print-record :tprint.prinfo.rpage.topLeft)
  (reverse-a-page-field print-record :tprint.prinfo.rpage.bottomRight)
  (reverse-a-page-field print-record :tprint.rpaper.topLeft)
  (reverse-a-page-field print-record :tprint.rpaper.bottomRight)
  (reverse-a-page-field print-record :tprint.prinfopt.rpage.topLeft)
  (reverse-a-page-field print-record :tprint.prinfopt.rpage.bottomRight))

(defmethod get-print-page ((self t))
  (with-open-printer (print-record :view self)
    (when (macptrp print-record)
      (values
       (point-string (href print-record :tprint.prinfo.rpage.topLeft))
       (point-string (href print-record :tprint.prinfo.rpage.bottomRight))
       (point-string (href print-record :tprint.rpaper.topLeft))
       (point-string (href print-record :tprint.rpaper.bottomRight))
       (point-string (href print-record :tprint.prinfopt.rpage.topLeft))
       (point-string (href print-record :tprint.prinfopt.rpage.bottomRight))))))

;; routines for determining the topLeft and bottomRight corners
;; of the printer-page
(defun get-page-size (pRec)
  (subtract-points (href pREC :tprint.prInfo.rpage.bottomRight)
                   (href pREC :tprint.prInfo.rpage.topLeft)))

(defmethod page-size ((self t))
  (with-open-printer (prec :view self)
    (get-page-size prec)))

(defmethod page-size ((window fred-window))
  (with-open-printer (prec :view window)
    (get-page-size prec)))

;; Routines for computing the corners of rectangular pictures and windows

(defun picture-corners (picture page-size)
  (declare (ignore page-size))
  ;; return the topleft and bottomRight corners of the picture
  (when (handlep picture)
    (values
     (rref picture picture.picframe.topleft)
     (rref picture picture.picframe.bottomRight))))

(defmethod window-document-corners ((view window) page-size)
  (declare (ignore page-size))
  ;; Computes the topLeft and bottomRight corners of the rectangle
  ;; for the view. Specialize to handle scrolling windows
  (view-corners view))

(defmethod view-document-corners ((view view) page-size)
  (declare (ignore page-size))
  ;; Computes the topLeft and bottomRight corners of the rectangle
  ;; for the view. Specialize to handle scrolling windows
  (view-corners view))

;; routines for computing the page layout (document size in pages-h x pages-v)
(defun compute-page-size (document-size page-size)
  ;; returns the point representing the document-size in pages width x depth
  (let* ((page-h (ceiling (point-h document-size) (point-h page-size)))
         (page-v (ceiling (point-v document-size) (point-v page-size))))
    (values
     page-h
     page-v
     (* page-h page-v))))

;; not currently used, can be used within the print-fn for a document-hardcopy
;; to determine the current page number, and row/column index
(defun compute-page-topLeft (page-size pages-h pages-v page-no)
  ;; given the size of the page-rectangle (page-size)
  ;;       the dimensions of the document in pages pages-h x pages-v
  ;;       the page number being printed
  ;; returns the page-no and the column/row position of the page
  ;;       and the coordinates of the upper left corner of the
  ;;       document corresponding to the page of size page-size
  (declare (ignore pages-v))
  (multiple-value-bind (real-v real-h)
                       (truncate page-no pages-h)
    (values
     page-no
     real-h
     real-v
    (make-point (* (point-h page-size) real-h)
                (* (point-v page-size) real-v)))))

;; default routines for printing a document and for determining its size
(defun default-document-hardcopy (view page-size page-no offset local)
  (declare (ignore view prRec page-size page-no offset local)))

(defun default-document-corners (view psize)
  (declare (ignore view))
  (values #@(0 0) psize))

(defun compute-page-layout (view page-size compute-doc-size)
  ;; uses the compute-doc-size function with view and page-size
  ;; to compute the size of the document in pages (pages-h x pages-v)
    (multiple-value-bind (top bottom)
                         (funcall (if (functionp compute-doc-size)
                                    compute-doc-size
                                    #'ccl::default-document-corners)
                                  view page-size)
      (compute-page-size (subtract-points bottom top) page-size)))


;; hardcopy routines for documents, windows and pictures

;;  General hardcopy routine
(defun document-hardcopy (print-fn document-corners &key (show-dialog? t) view (local t))
  (setq *print-error* nil)
  (let (offset
        ;progress
        page-size v-dim h-dim (page-no 0))
    ;(setq progress (get-print-dialog view))
    (with-cursor *arrow-cursor*
      (with-open-printer (prec :view view :show-dialog? show-dialog?)
        (with-cursor *watch-cursor*
          (when *printing*
            (clean-catch-cancel
             :doco
              (unwind-protect
                (setq page-size (get-page-size prec))
                (multiple-value-bind (pages-h pages-v pages)
                                     (compute-page-layout view page-size document-corners)
                  (decf pages-h)
                  (decf pages-v)
                  (unless (functionp print-fn)
                    (setq print-fn #'default-document-hardcopy))
                  ;(when (setq progress (get-print-dialog view :display t))
                    ;(window-select progress)
                    ;(event-dispatch))
                  (with-open-doc hardcopy-ptr prec
                    (let* ((from-page (max 1 (href prec :tprint.prJob.iFstPage)))
                           (to-page (min pages (href prec :tprint.prJob.iLstPage)))
                           (pages-to-print (1+ (- to-page from-page))))
                      ;; print pages-to-print pages (from from-page to to-page)
                      ;; adjust the print record to print only pages-to-print pages
                      (set-page-range prec pages-to-print)
                      (loop for v-page fixnum from 0 to pages-v
                            do (setq v-dim (* (point-v page-size) v-page))
                            (loop for h-page fixnum from 0 to pages-h
                                  do (incf page-no)
                                  (when (<= from-page page-no to-page)
                                    ;; only print pages in the range from-page to to-page
                                    (decf pages-to-print)
                                    (when *debug* (print-db pages-to-print))
                                    (setq h-dim (* (point-h page-size) h-page))
                                    (setq offset (make-point h-dim v-dim))
                                    (when *printing*
                                      ;(set-page-number view page-no :display t)
                                      (with-open-page (hardcopy-ptr page-size offset :local local)
                                        (funcall print-fn view page-size page-no offset local))))

                                  while (and *printing*   ; stop when printing canceled
                                             (> pages-to-print 0)))   ; or no pages to print

                            ; stop when no pages remain to print or printing is cancelled
                            while (and *printing* (> pages-to-print 0)))))))))
          (unless *printing*
            (unless *print-error*
              (setq *print-error* (make-condition 'printer-condition))
              (with-slots (phase code cond) *print-error*
                (setq phase $err-printer
                      code #$iPrAbort
                      cond nil))
              (call-trap 'prsetError #_PrSetError #$iPrAbort)))
          ;(remove-print-dialog view)
          (setq *printing* nil)
          (null *print-error*))))))

;; Internal routine for printing the contents of a views
(defmethod view-print-contents ((subview view)
                                page-size page-no offset local)
  (declare (ignore page-size page-no))
  (let ((*print-record-window* subview))
    (print-contents subview (if local #@(0 0)
                                offset))))

;; Print contents of a non-fred window, fred windows already defined
(defmethod window-hardcopy ((v window) &optional (show-dialog? t))
  (document-hardcopy #'view-print-contents #'window-document-corners
                     :view  v
                     :show-dialog? show-dialog?
                     :local t))

;; Print a picture on the printer
(defun picture-hardcopy (picture &optional (show-dialog? t))
  (when (handlep picture)
    (with-dereferenced-handles ((picture-ptr picture))
      (flet ((pict-draw (view page-size page-no offset local)
               (declare (ignore view page-no))
               (multiple-value-bind (topLeft bottomRight)
                                    (picture-corners picture page-size)
                 (with-rectangle-arg (r topLeft bottomRight)
                   (unless local (call-trap 'offsetRect #_offsetRect :ptr r :long (subtract-points #@(0 0) offset)))
                   (call-trap 'drawPicture #_drawPicture :ptr picture :ptr r))))
             (pict-size (view page-size)
               (declare (ignore view))
               (picture-corners picture page-size)))
        (declare (dynamic-extent #'pict-draw #'pict-size))
        (document-hardcopy #'pict-draw #'pict-size :show-dialog? show-dialog?)))))


;;;; functions to setup the environment for printing
;; changes the page setup menu item to use the new Page Setup function
(defun fix-file-menu ()
  (let ((page-setup (find-menu-item *file-menu* "Page Setup"))
        (print (find-menu-item *file-menu* "Print")))
    (when page-setup
      (change-class page-setup 'window-menu-item)
      (setf (menu-item-action-function page-setup)
            #'(lambda (window)
                (eval-enqueue `(page-setup ,window)))))
    (when print
      (setf (menu-item-action-function print)
            #'(lambda (window)
                (eval-enqueue `(ccl::window-hardcopy ,window)))))
    (setq *printing* nil)))

(defun remove-hc-prec ()
  ;; clean up the internal tprint handle
  ;; modify if you need to clean up others
  (remove-prec t))

(defun setup-printing ()
  ;; remove and then add #'fix-file-menu to end of *lisp-startup-functions*
  (setq *lisp-startup-functions*
        (remove 'fix-file-menu *lisp-startup-functions* :key #'function-name))
  (setq *printing* nil)
  (push #'fix-file-menu *lisp-startup-functions*)
  (setq *save-exit-functions*
        (remove 'remove-hc-prec *save-exit-functions* :key #'function-name))
  (push #'remove-hc-prec *save-exit-functions*))

;; Routines for changing the line width for PostScript devices
;;  Routines can be used to build pictures
;;  or within a document-hardcopy
;; The routines change the printed output only for PostScript devices
;;
;;
(defun scale-line-width (scale)
  (unless (rationalp scale)
    (error "~A is not a Rational" scale))
  (let ((h (denominator scale))
        (v (numerator scale)))
    (let ((width-h (call-trap 'newHandle #_NewHandle (record-length :fixedPoint))))
      (unless (valid-handle width-h)
        (error "unable to allocate a ~a temporary record handle (~a bytes)."
               (record-length :fixedPoint)))
      (unwind-protect
        (progn
          (with-dereferenced-handles ((width-p width-h))
            (call-trap 'setPt #_setpt (:pointer :point) width-p
                          :signed-integer h
                          :signed-integer v))
          (call-trap 'picComment #_piccomment :word $set-line-width :word 4 :ptr width-h))
        (dispose-handle width-h)))))

(defun normal-line-width ()
  (scale-line-width 1))

;; setup the printing enviroment and fix the Page setup menu item
(setup-printing)
(fix-file-menu)

;; augment the window-hardcopy, window-save, print-style-dialog
;; and get-print-record routines
(advise ccl::window-hardcopy
        (let* ((*print-record-window* (car arglist))
               (*hc-prec* (with-open-printer (prec :view *print-record-window*)
                            (get-print-prec *print-record-window*))))
          (:do-it))
        :when :around)

(advise ccl::window-save-file
        (let ((*print-record-window* (car arglist))
              window-file)
          (setq window-file (:do-it))
          (when window-file
            (with-open-printer (prec :view *print-record-window*)
              (get-print-prec *print-record-window*)
              (update-file-prec *print-record-window*
                           (get-prec *print-record-window*)
                           window-file)))
          window-file)
        :when :around)

(advise ccl::print-style-dialog
        (let ((*print-record-window* (front-window))
              result)
          (setq result (:do-it))
          (with-open-printer (prec :view *print-record-window*)
            (get-print-prec *print-record-window*)
            (update-file-prec *print-record-window* (prec-get *print-record-window*)))
          result)
        :when :around)

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

  (defun get-print-record ()
    (if *print-record-window*
      (get-prec *print-record-window*)
      (funcall *mcl-get-print-record*)))

  )


#|
(defun make-print-demo ()
  "Create the experiment application"
  (let ((target-appl (choose-new-file-dialog :directory "ccl;print-demo")))
    (save-application target-appl
                      :excise-compiler nil    ; do want the compiler
                      :creator :glop
                      :clear-clos-caches nil ; otherwise we can't access classes
                      )))
(make-print-demo)
|#

#|
;;;  Four printing examples and two examples of saving private print records
;;;
;;;  Five printing examples:
;;;  - contents of a small window
;;;  - a picture
;;;  - contents of a large window
;;;  - a general document
;;;  - a window with a view-draw-contents method that calls a print-contents method

(defvar *w1*)
(defvar *test-window*)
(defvar *picture*)
(require 'quickdraw)


;;---------------------- printing the contents of a small window ------------------------
;; Create a window with nested views and print it.
(setq *w1* (make-instance 'window
            :window-title "HI there"
            :view-size #@(300 300)
            :view-subviews
               (list (make-instance 'view
                   :view-position #@(20 20)
                   :view-size #@(150 130)
                   :view-subviews
                       (List (make-instance 'static-text-dialog-item
                                 :view-position #@(10 10)
                                 :view-size #@(130 40)
                                 :view-font '("Helvetica" :srcor :bold 12)
                                 :dialog-item-text
                                    "how now said the big brown cow")
                             (make-instance 'static-text-dialog-item
                                            :view-position #@(10 70)
                                            :view-size #@(130 60)
                                            :view-font '("Geneva" :srcor :underline 14)
                                            :dialog-item-text
                                            "there is a bunch of green cheese here on the moon")))
                     (make-instance 'button-dialog-item
                                            :view-position #@(160 160)
                                            :view-size #@(72 16)
                                            :dialog-item-text "Green"))))

(window-hardcopy *w1*)                  ; print the window
                                        ; Also select the window and do a file Print

;;---------------------------- printing a picture -----------------------------
;; Print a picture. The picture corresponds to a picture of the print-contents
;; of the window w1 using a window twice the size.
(let ((view-size (view-size *w1*)) mid-point)
  (when (and (boundp '*picture*) (handlep *picture*))
    (kill-picture *picture*))
  (with-focused-view *w1*
    (start-picture *w1* #@(0 0) (make-point (* 2 (point-h view-size))
                                            (* 2 (point-v view-size))))
    (print-contents *w1*)
    (setq *picture* (get-picture *w1*)))

  ;; draw the picture at half- in the bottom right corner of *w1*
  (window-select *w1*)
  (sleep 1)
  (setq mid-point (make-point (floor (point-h view-size) 2)
                              (floor (point-v view-size) 2)))
  (draw-picture *w1* *picture* mid-point (add-points (view-size *w1*) mid-point))
  (sleep 1)
  (print-record *picture* :picture) (terpri)
  (picture-hardcopy *picture*)              ; print the picture
  (kill-picture *picture*)                  ; remove the picture
  )


;;;  -
;;-------------------- printing the contents of a large window ---------------------
;;  Print the contents of a large dialog (918 x 708)
(setq *test-window*
   (make-instance 'color-dialog
               :window-type :document-with-zoom
               :view-position #@(100 100)
               :view-size #@(918 708)
               :view-font '("Chicago" 12 :SRCOR :PLAIN)
               :view-subviews
               (list (make-instance 'static-text-dialog-item
                                       :view-position #@(13 9)
                                       :view-size #@(56 16)
                                       :dialog-item-text "Untitled")

                     (make-instance 'editable-text-dialog-item
                                       :view-position #@(15 25)
                                       :view-size #@(84 16)
                                       :dialog-item-text "Untitled"
                                       :allow-returns nil)

                     (make-instance 'button-dialog-item
                                       :view-position #@(15 47)
                                       :view-size #@(62 16)
                                       :dialog-item-text "Untitled"
                                       :default-button nil)

                     (make-instance 'editable-text-dialog-item
                                       :view-position #@(381 683)
                                       :view-size #@(114 16)
                                       :dialog-item-text "bottom center"
                                       :allow-returns nil)

                     (make-instance 'editable-text-dialog-item
                                       :view-position #@(11 688)
                                       :view-size #@(84 16)
                                       :dialog-item-text "bottom left"
                                       :allow-returns nil)

                     (make-instance 'editable-text-dialog-item
                                       :view-position #@(375 20)
                                       :view-size #@(84 16)
                                       :dialog-item-text "top center"
                                       :allow-returns nil)

                     (make-instance 'editable-text-dialog-item
                                       :view-position #@(799 676)
                                       :view-size #@(84 16)
                                       :dialog-item-text "bottom right"
                                       :view-font
                                       '("New Century Schlbk"
                                         12 :SRCOR :PLAIN)
                                       :allow-returns nil)

                     (make-instance 'editable-text-dialog-item
                                       :view-position #@(818 20)
                                       :view-size #@(84 16)
                                       :dialog-item-text "top right"
                                       :view-font
                                       '("New Century Schlbk"
                                         12 :SRCOR :PLAIN)
                                       :allow-returns nil)))
)

(window-hardcopy *test-window*)           ; print the large dialog

;;---------------------- printing a general document -----------------------
;;  Print a document of size 552 x 1460 pixels
;;  This requires two 8.5" x 11" pages at normal size (Reduce/Enlarge 100%)
;;  At normal size prints two pages with
;;  "Now is the time for all good men to come to the aid" on the first page
;;  twice on the first page at #@(50 50) and #@(50 100)
;;  and with the string "When johnny comes marching home again" in the
;;  relative positions #@(200 0) and #@(50 100) on the second page.
;;  At 50% or smaller reduction, prints only the first page, reduced.
;;  At 200% or greater reduction prints two pages, enlarged.

;;  When 50% reduction, prints only one "page"
(defun my-hardcopy-fn (view page-size page-no offset local)
  (declare (ignore view page-size))
  (unless local (setq offset #@(0 0)))
  (let ((text "Now is the time for all good men to come to the aid"))
    (with-font-spec '("Times" 18 :srcor :plain)
      (if (= page-no 0)
        (call-trap #_moveTo :long (add-points #@(50 50) offset))
        (progn (call-trap #_moveTo :long (add-points #@(200 0) offset))
               (setq text "When johnny comes marching home again")))
      (with-returned-pstrs ((text-buff text))
        (call-trap #_DrawText :ptr text-buff :integer 1 :integer (length text)))
      (call-trap #_moveTo :long (add-points #@(50 100) offset))
      (with-returned-pstrs ((text-buff text))
        (call-trap #_DrawText :ptr text-buff :integer 1 :integer (length text)))
      )))

(defun my-document-corners (view page-size)
  (declare (ignore view page-size))
  ;; a document on 8.5 x 11 paper 1 wide and 2 high
  (values #@(0 0) (make-point 552 (* 2 730))))

(document-hardcopy #'my-hardcopy-fn #'my-document-corners)   ; print the document

;;-------------------- a window with a view-draw-contents calling print-contents -----------
(defclass my-window (window) nil
  (:default-initargs :window-title "*print me*"))
(defvar *win*)

;; this method does not work - the commands do not appear in the postscript file
(defmethod view-draw-contents ((window my-window))
  (with-focused-view window
    (#_moveto 0 0)
    (#_lineto 100 0)
    (#_lineto 100 200)
    (#_lineto 0 200)
    (#_lineto 0 0)
    (#_lineto 100 200)
    (#_lineto 200 0)
    (#_lineto 300 50)))

;; the commands appear in the postscript file
(defmethod view-draw-contents ((window my-window))
  (with-focused-view window
    (display-contents window)))

(defmethod display-contents ((window my-window))
    (#_moveto 10 10)
    (#_lineto 100 10)
    (#_lineto 100 200)
    (#_lineto 10 200)
    (#_lineto 10 10)
    (#_lineto 100 200)
    (#_lineto 200 0)
    (#_lineto 300 50))

(defmethod print-contents ((window my-window) &optional (offset #@(0 0)))
  (declare (ignore offset))
  (call-next-method)
  (display-contents window))

(setq *win* (make-instance 'my-window
              :view-size #@(400 400)))
;; (window-close *win*)
;;;  -
;;-------------------- changing the page setup atributes of a file ---------------------
;; open an existing file in a fred window,
;; change the page setup attributes and reopen the file
(defvar *test-window*)
(defvar *file-name*)
(setq *test-window* (fred (choose-file-dialog :button-string "Edit")))
(setq *file-name* (view-file-name *test-window*))

;; Change the page setup
(page-setup *test-window*)
(window-close *test-window*)

;; open the file again and see that the attributes have changed
(setq *test-window* (fred *file-name*))
(page-setup *test-window*)

;; open the file and see that the :prec resource has been saved
(with-open-resource-file (refnum *file-name* :if-does-not-exist nil)
  (let (printer-record)
    (setq printer-record (get-resource :prec 128 :errorp nil))
    (print-db printer-record)
    (when (valid-handle printer-record)
      (print-record printer-record :tprint))))

;;;  -
;;-------------------- views that store their print record in a slot ---------------------
;;  the slot is ccl::my-print-record

(defclass print-view (view)
  ((my-print-record :initform nil)
   (my-file-name :initform nil)))

(defclass print-window (print-view window) nil)

(defmethod view-file-name ((view print-view))
  (slot-value view 'my-file-name))

(defmethod view-get ((view print-view) flag &optional option)
  (declare (ignore option))
  (if (equal flag :prec)
      (slot-value view 'my-print-record)
      (call-next-method)))

(defmethod view-put ((view print-view) flag value)
  (if (equal flag :prec)
    (setf (slot-value view 'my-print-record) value)
    (call-next-method)))

(setq *test-window* (make-instance 'print-window))
(setq *file-name* (choose-file-dialog))

;; change the page setup attributes, they'll be saved with the file
(page-setup *test-window*)
(window-close *test-window*)

;; create another window into the same "file"
;; and see that the print-record has been restored.
(setq *test-window* (make-instance 'print-window))
(setf (slot-value *test-window* 'my-file-name) *file-name*)
(page-setup *test-window*)


;;;  -
;;-------------------- printing pictures with different line widths ---------------------

An example which creates two pictures, displays both at 400% scale,
and prints them.

Assumptions:
   The display device has a horizontal/vertical resolution of 72 pixels/inch
   The PostScript device resolution is 300 pixels/inch.
   The PageSetup is normal
       no enlargement/reduction
       no precision bit map
       etc.

Each picture is the result of drawing a line of size #@(1 1)
from #@(0 0) to #@(100 100),coinciding with two corners of
the picture rectangle.

When the first picture is printed, the lines are normal size.
When the second picture is printed, the lines are hairline 1/4 thickness.

                    ; use quickdraw routines
(let (that
      new-picture)
  (eval-when (eval load compile)
    (require :quickdraw))
  (setq that (make-instance 'window))
  (window-select that)
  (set-view-size that 400 400)
  (loop for scaling in '(nil t)
        do(progn
            (with-focused-view that
              (start-picture that 0 0 100 100)
              (when scaling
                (scale-line-width 1/4))
              (call-trap #_moveto 0 0)
              (call-trap #_lineto 100 50)
              (when scaling
                (normal-line-width)))
            (setq new-picture (get-picture that))
            (draw-picture that new-picture 0 0 400 400)
            (picture-hardcopy new-picture)
            (kill-picture new-picture)))
  (window-close that))


Here's the end of the PostScript code corresponding to the first picture

T T 0 0 730 552 -31 -30 761 582 100 72 72 1 F F F F T T T F psu
(LARRY     Ecstatic; document: Untitled)jn
0 mf
od
%%EndDocumentSetup
%%Page: ? 1
op
0 0 730 552 fr
0 0 xl
1 1 pen
0 0 gm
(nc 0 0 100 100 6 rc)kp
50 100 lin
F T cp
%%Trailer
cd
end
%%Pages: 1 0
%%EOF

Here's the end of the PostScript code corresponding to the second picture

T T 0 0 730 552 -31 -30 761 582 100 72 72 1 F F F F T T T F psu
(LARRY     Ecstatic; document: Untitled)jn
0 mf
od
%%EndDocumentSetup
%%Page: ? 1
op
0 0 730 552 fr
0 0 xl
1 1 pen
0 0 gm
(nc 0 0 0 0 6 rc)kp
1 4 lw
(nc 0 0 100 100 6 rc)kp
50 100 lin
1 1 lw
F T cp
%%Trailer
cd
end
%%Pages: 1 0
%%EOF

|#
;;; end of file